home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.06 Jun 89 / Lisp sources / structures / towerByRules < prev    next >
Encoding:
Text File  |  1988-06-01  |  6.6 KB  |  165 lines  |  [TEXT/CCL ]
  1. ; Ted Kaehler and Dave Patterson a taste of SmallTalk
  2. ; W. W. Norton ed., chapter 6, pp. 83 ff.
  3. ; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
  4. ; © Copyright 1988 Jean-Pascal J. LANGE.
  5.  
  6. (proclaim '(optimize (speed 3)
  7.             (space 0)
  8.             (safety 0)
  9.             (compilation-speed 0) ))
  10.  
  11. (defStruct (towerByRules (:include animatedTowerOfHanoi))
  12. #| An object of this class represents the game. It holds an array
  13.    of stacks that hold disks. It also keeps track of which disk
  14.    just moved and which disk should move next.
  15.    The new instance variables are
  16.        oldDisk the disk that was moved last time,
  17.        currentDisk we are considering moving this disk,
  18.        destinationDisk and putting it on top of this disk.|#
  19.   (oldDisk nil)
  20.   (currentDisk nil)
  21.   (destinationDisk nil) )
  22.  
  23. ; initialize
  24.  
  25. (deFun HanoiRules (thisTower)
  26. ; asks the user how many disks, set up the game and move disks until
  27. ; we are done
  28.   (declare (special *TheTowers* *Thickness* *DiskGap*))
  29.   (do ()
  30.       ((integerp (howMany thisTower)))
  31.     (format t "~&Please type the number of disks in the tower: ")
  32.     (setf (towerByRules-howMany thisTower) (read)) )
  33.   (oneOf *window*
  34.          :window-title "heuristic animated towers of Hanoï"
  35.          :window-position #@(20 100)
  36.          :window-size #@(360 220)
  37.          :window-type :single-edge-box )
  38.   
  39.   (setUpDisksRules thisTower)     ; create the disks and stacks
  40.   
  41.   (loop ; iterate until all disks are on one tower again.
  42.     (let* ((currentDisk (decide thisTower))
  43.            ; decide which to move and also set destinationDisk
  44.            (currentPole (pole currentDisk))
  45.            (destinationPole
  46.             (pole (towerByRules-destinationDisk thisTower)) ) )
  47.       (removeFirst (towerByRules-stacks thisTower)
  48.                    (1- currentPole) )
  49.       (addFirst (towerByRules-stacks thisTower)
  50.                 (1- destinationPole) currentDisk )
  51.       #|(format t "~&~D -> ~D : ~A"
  52.               currentPole destinationPole (name currentDisk) )|#
  53.       ; tell the disk where it is now
  54.       (moveUponRules currentDisk (towerByRules-destinationDisk thisTower))
  55.       ; get ready for the next move
  56.       (setf (towerByRules-oldDisk thisTower) currentDisk) )
  57.     (when (allOnOneTower thisTower) (return)) ) ; test if done
  58.   ; so on next run, howMany will be re-initialized
  59.   (setf (towerByRules-howMany thisTower) nil)
  60.   (makUnbound '*TheTowers*)
  61.   (makUnbound '*Thickness*)
  62.   (makUnbound '*DiskGap*)
  63.   nil ) ; HanoiRules
  64.  
  65. (deFun setUpDisksRules (thisTower)
  66. ; Creates the disks and set up the poles. Tells all disks what game
  67. ; they are in and set disk thickness and gap.
  68.   (whichTowers thisTower)
  69.   (let ((displayBox
  70.          (originCorner #@(0 0) (ask (front-window) (window-size))) ))
  71.     (erase displayBox)
  72.     (border displayBox 2) )
  73.   ; the poles are an array of three stacks. Each stack is a list.
  74.   (setf (towerByRules-stacks thisTower)
  75.         (make-array 3 :initial-element nil) )
  76.   (let ((disk)
  77.         (size (howMany thisTower)) )
  78.     (doTimes (i (howMany thisTower))
  79.       (setq disk (make-HanoiDiskRules))        ; create a disk
  80.       (widthPoleRules disk size 1)
  81.       ; don't forget: the first element of an array is at index 0 !!!
  82.       ; push it onto a stack
  83.       (addFirst (towerByRules-stacks thisTower) 0 disk)
  84.       (invert disk)                  ; show on the screen
  85.       (setq size (1- size)) ) )
  86.   
  87.   ; When a pole has no disk on it, one of these mock disks acts as a
  88.   ; bottom disk. A moving disk will ask a mock disk its width and pole number.
  89.   (setf (towerByRules-mockDisks thisTower)
  90.         (make-array 3 :initial-element nil) )
  91.   (let ((disk))
  92.     (doTimes (index 3)
  93.       (setq disk (make-HanoiDiskRules))
  94.       ; don't forget: a doTimes-loop index starts at 0 !!!
  95.       (widthPoleRules disk 1000 (1+ index))
  96.       (setf (aRef (towerByRules-mockDisks thisTower) index)
  97.             disk ) ) )
  98.   ; on the first move, look for another disk (a real one) to move
  99.   ; don't forget: the first element of an array is at index 0 !!!
  100.   (setf (towerByRules-oldDisk thisTower)
  101.         (aRef (towerByRules-mockDisks thisTower) 2)) )
  102. ; setUpDisksRules
  103.  
  104. ; moves
  105.  
  106. (deFun allOnOneTower (thisTower)
  107. ; return true if all of the disks are on one tower
  108.   (doTimes (index (length (towerByRules-stacks thisTower)) nil)
  109.     (if (= (length (aRef (towerByRules-stacks thisTower) index))
  110.            (howMany thisTower) )
  111.       (return t) ) ) ) ; allOnOneTower
  112.  
  113. (deFun decide (thisTower)
  114. ; use the last disk moved (oldDisk) to find a new disk to move
  115. ; (currentDisk) and a disk to put it on top of (destinationDisk).
  116.   (topsOtherThan
  117.    thisTower
  118.    (towerByRules-oldDisk thisTower)
  119.    #'(lambda (movingDisk)
  120.        (cond ((hasLegalMove movingDisk)
  121.               ; remember the disk upon which to move
  122.               (setf (towerByRules-destinationDisk thisTower)
  123.                     (bestMove movingDisk) )
  124.               ; return the disk that moves
  125.               movingDisk ) ) ) ) ) ; decide
  126.  
  127. (deFun polesOtherThan (thisTower thisDisk aBlock)
  128. ; evaluate the block of code using the top disk on each of the other
  129. ; two poles. If a pole is empty, use the mock disk for that pole.
  130.   (doTimes (aPole 3)
  131.     ; Want a pole other than the pole of thisDisk
  132.     ; don't forget: a doTimes-loop index starts at 0 !!!
  133.     (if (not (= (1+ aPole) (pole thisDisk)))
  134.       (let
  135.         ((result
  136.           (if (null (aRef (towerByRules-stacks thisTower) aPole))
  137.             ; if the pole is empty, use a mock disk…
  138.             (funCall aBlock
  139.                      (aRef (towerByRules-mockDisks thisTower)
  140.                            aPole ) ) ; execute the block
  141.             ; …else use the top disk
  142.             (funCall aBlock ; execute the block
  143.                      (first (aRef (towerByRules-stacks thisTower)
  144.                                   aPole )) ) ) ))
  145.         (when result (return result)) ) ) ) ) ; polesOtherThan
  146.  
  147. (deFun topsOtherThan (thisTower thisDisk aBlock)
  148. ; evaluate the block of code using the top disk on each of the other
  149. ; two poles. If a pole is empty, ignore it. This is for actual disks.
  150.   (doTimes (aPole 3)
  151.     ; If the pole does not have thisDisk and is not empty, then
  152.     ; execute aBlock (don't forget: a doTimes-loop index starts at 0)
  153.     (if (and (not (= (1+ aPole) (pole thisDisk)))
  154.              (not (null (aRef (towerByRules-stacks thisTower)
  155.                               aPole ))) )
  156.       (let ((result
  157.              (funcall aBlock ; execute the block
  158.                       (first (aRef (towerByRules-stacks thisTower)
  159.                                    aPole )) ) ))
  160.         (when result (return result)) ) ) ) ) ; topsOtherThan
  161.  
  162. (deFun removeFirst (array index)
  163. ; removeFirst is the procedure for pop.
  164.   (setf (aRef array index) (cdr (aRef array index))) ) ; removeFirst
  165.